perm filename OCCULT[GEM,BGB]1 blob
sn#032396 filedate 1973-03-30 generic text, type T, neo UTF8
00100 TITLE OCCULT - A HIDDEN LINE ELIMINATOR - FEBRUARY 1973.
00200
00300 ;OCCULT IS DEPENDENT ON THE WING AND EULER PRIMITIVES.
00400
00500 EXTERN MKB,MKF,MKE,MKV
00600 EXTERN KLB,KLF,KLE,KLV
00700 EXTERN WING,LINKED
00800 EXTERN ECW,ECCW,OTHER
00900 EXTERN BGET,FCW,FCCW,VCW,VCCW
01000 EXTERN MKEV,MKFE,ESPLIT,KLEV,KLFE
01100 EXTERN INVERT
01200
01300 ;LINK NAMES RELEVANT ONLY TO OCCULT.
01400
01500 DEFINE UFACE(Q,E)<CAR Q,7(E)> ;UBER/UNDER FACE.
01600 DEFINE UFACE.(Q,E)<DIP Q,7(E)>
01700 DEFINE TJ(Q,V)<CAR Q,7(V)> ;TJOINT LIST.
01800 DEFINE TJ.(Q,V)<DIP Q,7(V)>
01900 TJLIST:0
02000 DEFINE VALEN(Q,V)<CAR Q,7(V)> ;VERTEX VALENCE.
02100 DEFINE VALEN.(Q,V)<DIP Q,7(V)>
02200 DEFINE TJOINT(Q,V)<CAR Q,2(V)> ;TJOINT RING.
02300 DEFINE TJOIN.(Q,V)<DIP Q,2(V)>
02400
02500 ;DIAGONOSTICS.
02600
02700 DECLARE{TIME1,TIME2}
02800 WORLD:0
02900 EXTERN EDPY,VDPY
03000 EXTERN DPYSET,DPYBUF,DPYOUT,DPYBRT,DPYBIG,BUFDPY
03100 EXTERN AIVECT,AVECT,FLODPY,DECDPY,DPYSTR,DTYO
03200 DMODE:-1
03300 ELIMIT: =12
03400 PDLTOP:0
03500 DEEPDL:BLOCK =1024
03600 WNDCNT:0 ;NUMBER OF XY-SORT WINDOWS.
03700 COMCNT:0 ;NUMBER OF EDGE-EDGE COMPARES.
03800
03900 ;OUTER MOST WINDOW FROM PROJECTOR.
04000
04100 DECLARE{XPPMIN,XPPMAX,YPPMIN,YPPMAX,ZPPMIN,ZPPMAX}
04200 DECLARE{VXMIN,VXMAX,VYMIN,VYMAX,VZMIN,VZMAX}
00100 SUBR(OCCULT)WORLD ---------------------------------------------
00200 BEGIN OCCULT; A HIDDEN LINE ELIMINATOR.
00300
00400 TDCA 1,1 ;CLEAR DIAGONOSTIC MODE ON ENTRY.
00500 SETO 1, ;SET DIAGONOSTIC MODE ON ENTRY+1.
00600 DAC 1,DMODE
00700
00800 ;READ CLOCKS.
00900 SETZ↔TIMER↔DAC TIME1
01000 SETZ↔RUNTIM↔DAC TIME2
01100
01200 ;TRY TO HIDE VERTICES THAT WERE HIDDEN BEFORE.
01300 DZM TJLIST
01400 DZM COMCNT↔DZM WNDCNT
01500 LAC ARG1↔DAC WORLD
01600 CALL(VSCAN)
01700
01800 ;PLACE OUTERMOST WINDOW INTO THE DEEP PDL.
01900 DZM PDLTOP
02000 LACI 1,DEEPDL
02100 DZM(1) ;WINDOW CUT DIRECTION.
02200
02300 LAC 2,ARG1
02400 DAC 2,WORLD
02500 PED 2,2 ;LAST POTENT EDGE.
02600
02700 PUSH 1,2
02800 PUSH 1,[1] ;CURRENT EDGE COUNT.
02900 PUSH 1,XPPMIN ;OUTER MOST WINDOW.
03000 PUSH 1,XPPMAX
03100 PUSH 1,YPPMIN
03200 PUSH 1,YPPMAX
03300 PUSH 1,2 ;ONLY EDGE IN WINDOW.
03400 ZIP 1
03500
03600 ;DO THIS WINDOW AND ALL ITS FRIENDS.
03700 CALL(XYSORT,1)
03800 CALL(TJSCAN)
03900 CALL(STAT)
04000 POP1J
04100
04200 BEND OCCULT;BGB 2/25/73 ---------------------------------------
00100 SUBR(XYSORT)S0-------------------------------------------------
00200 BEGIN XYSORT; DO WINDOW OR SPLIT IT IN TWO - BGB 25 FEB 1973.
00300 ACCUMULATORS{S0,S1,S2,E,A}
00400
00500 ;WINDOW DEEP STACK BLOCK FORMAT.
00600 CUTFLG ←← -7 ;CUT DIRECTION SWITCH. 0 IN X. -1 IN Y.
00700 ELAST ←← -6 ;LAST POTENT EDGE.
00800 EDGCNT ←← -5 ;EDGE COUNT
00900 XLO ←← -4 ;XL
01000 XHI ←← -3 ;XH
01100 YLO ←← -2 ;YL
01200 YHI ←← -1 ;YH
01300
01400 ;PUSH LATE BORN EDGES INTO THE CURRENT WINDOW.
01500 LAC S0,ARG1 ;WINDOW POINTER.
01600 LAC 1,EDGCNT(S0) ;EDGE COUNT.
01700 DIP 1,1 ;XWD ECNT,,ECNT
01800 ADDI 1,-1(S0) ;XWD ECNT,,S0+ECNT-1
01900 LAC E,ELAST(S0) ;LAST POTENT EDGE.
02000 L1: LAC A,E↔POTEN E,E
02100 JUMPE E,L2
02200 TEST E,POTENT↔GO L1
02300 PUSH 1,E
02400 GO L1
02500 L2: HLRZM 1,EDGCNT(S0) ;UPDATE EDGE COUNT.
02600 DAC A,ELAST(S0) ;UPDATE LAST POTENT EDGE.
02700 ANDI 1,377777↔SUBI 1,DEEPDL
02800 CAMLE 1,PDLTOP↔DAC 1,PDLTOP
02900 GO .+6
03000 CALL(WINDPY,ARG1)
03100 CALL({VERIFY+2},[ASCII/XSORT/],[0])
03200
03300 ;WINDOW ZERO POINTERS AND SIZE.
03400 LAC S0,ARG1↔DAC S0,BEG0
03500 LAC EDGCNT(S0)↔DAC SIZ0
03600 LACN↔SLAC↔LAP S0↔DAC P0
03700 LAC BEG0↔ADD SIZ0↔SOS↔DAC END0
03800
03900 ;TEST FOR SMALL ENUF WINDOW POPULATION.
04000 LAC SIZ0↔CAMGE ELIMIT ;THRESHOLD EDGE COUNT.
04100 GO[CALL(ESCAN,BEG0)↔POP1J]
00100 ;COPY POTENT RIGHT HALVES TO LEFT.
00200 LAC S0,P0
00300 L3: LAC E,(S0)
00400 TEST E,POTENT↔SETZ E,
00500 DIP E,E↔DAC E,(S0)
00600 AOBJN S0,L3
00700
00800 ;CLIP EDGES INTO FIRST WINDOW.
00900 XL←←13 ↔ XH←←14 ↔ YL←←15 ↔ YH←←16
01000 L4: LAC S0,BEG0↔SLACI XLO(S0)↔LAPI XL↔BLT YH ;GET WINDOW 0.
01100 LAC XH↔FSB XL↔CAMGE[1.0]↔POP1J
01200 LAC YH↔FSB YL↔CAMGE[1.0]↔POP1J
01300 LACM 1,CUTFLG(S0)↔ASH 1,1
01400 LAC XL(1)↔FAD XH(1)
01500 FSC -1↔DAC MID#
01600 SKIPE CUTFLG(S0)
01700 SKIPA YH,MID
01800 LAC XH,MID ;MAKE WINDOW 1.
01900 LAC[XWD XL,W1]↔BLT W1+3 ;SAVE WINDOW 1.
02000 LAC 1,P0↔SETZ ;CLEAR INSIDER COUNT.
02100 CAR 2,(1)↔CALL(CLIP)
02200 ZIP(1)↔AOBJN 1,.-3
02300 DAC SIZ1
02400
02500 ;CLIP EDGES INTO SECOND WINDOW.
02600 L5: LAC S0,BEG0
02700 SLACI XLO(S0)
02800 LAPI XL↔BLT YH ;GET WINDOW 0.
02900 SKIPE CUTFLG(S0)
03000 SKIPA YL,MID
03100 LAC XL,MID ;MAKE WINDOW 2.
03200 LAC 1,P0↔SETZ ;INSIDER EDGE COUNT.
03300 CDR 2,(1)↔CALL(CLIP) ;LOOP EDGES,
03400 ZAP(1)↔AOBJN 1,.-3 ;THRU CLIP.
03500
00100 ;TEST FOR EMPTY WINDOWS.
00200 L5A: DAC SIZ2↔ADD SIZ1
00300 SKIPN↔POP1J ;BOTH WINDOWS EMPTY.
00400 SKIPE SIZ1↔GO L5B ;WINDOW 1 EMPTY.
00500 LAC S0,BEG0↔LAC MID↔SKIPE CUTFLG(S0)↔ADDI S0,2
00600 DAC XLO(S0)↔LAC 1,P0↔HRLS(1)↔AOBJN 1,.-1
00700 SETCMM CUTFLG(S0)↔GO L4
00800 L5B:
00900 SKIPE SIZ2↔GO L6 ;WINDOW 2 EMPTY.
01000 LAC S0,BEG0↔LAC MID↔SKIPE CUTFLG(S0)↔ADDI S0,2
01100 DAC XHI(S0)↔LAC 1,P0↔HLRS(1)↔AOBJN 1,.-1
01200 SETCMM CUTFLG(S0)↔GO L4
01300
01400 ;SETUP WINDOW POINTERS.
01500 L6: LAC BEG0↔DAC BEG2
01600 ADD SIZ2↔SOS↔DAC END2
01700 ADDI 8↔DAC BEG1
01800 ADD SIZ1↔SOS↔DAC END1
01900 LACN SIZ2↔HRL BEG2↔MOVSM P2 ;AOBJN POINTER 2.
02000 LACN SIZ1↔HRL BEG1↔MOVSM P1 ;AOBJN POINTER 1.
02100
02200 JSR REPACK
02300 LAC S1,BEG1
02400 LAC S2,BEG2
02500
02600 ;SETUP WINDOW HEADER DATA.
02700 L7: LAC ELAST(S2)↔DAC ELAST(S1) ;LAST POTENT EDGE.
02800 SLACI XL↔LAPI XLO(S2)↔BLT YHI(S2) ;WINDOWS.
02900 SLACI W1↔LAPI XLO(S1)↔BLT YHI(S1)
03000 LAC SIZ1↔DAC EDGCNT(S1) ;WINDOW EDGE COUNTS.
03100 LAC SIZ2↔DAC EDGCNT(S2)
03200 SETCMB CUTFLG(S2)↔DAC CUTFLG(S1) ;CUT DIRECTION SWITCH.
03300
03400 ;TWO CALLS ON XYSORT.
03500 DAC S2,ARG1 ;CONVERT CURRENT EXECUTION TO SECOND.
03600 CALL(XYSORT,S1) ;FIRST CALL.
03700 GO XYSORT ;SECOND CALL.
03800
03900 ;DATA GLOBAL TO CLIP AND REPACK.
04000 DECLARE{BEG0,END0,SIZ0,P0}
04100 DECLARE{BEG1,END1,SIZ1,P1}
04200 DECLARE{BEG2,END2,SIZ2,P2}
04300 W1:0↔0↔0↔0 ;WINDOW 1 SAVE AREA.
04400
04500 ;2/25/73----------------------------------------------------------
00100 SUBR(CLIP)-----------------------------------------------------
00200 BEGIN CLIP; CLIP DETECTOR - SKIP WHEN EDGE CROSSES WINDOW.
00300 ;ARGUMENTS EXPECTED TO BE IN ACCUMULATORS XL,XH,YL,YH & 2.
00400 ACCUMULATORS{C0,C1,C2,X0,X1,X2,Y0,Y1,Y2,XL,XH,YL,YH}
00500 SKIPN 2↔POP0J
00600 PVT C1,2↔LAC X1,XPP(C1)↔LAC Y1,YPP(C1)
00700 NVT C2,2↔LAC X2,XPP(C2)↔LAC Y2,YPP(C2)
00800
00900 SETZB C1,C2
01000 CAML Y1,YH↔IORI C1,8 ;NORTH.
01100 CAMG Y1,YL↔IORI C1,4 ;SOUTH.
01200 CAML X1,XH↔IORI C1,2 ;EAST.
01300 CAMG X1,XL↔IORI C1,1 ;WEST.
01400 JUMPE C1,HIT
01500
01600 CAML Y2,YH↔IORI C2,8 ;NORTH.
01700 CAMG Y2,YL↔IORI C2,4 ;SOUTH.
01800 CAML X2,XH↔IORI C2,2 ;EAST.
01900 CAMG X2,XL↔IORI C2,1 ;WEST.
02000 JUMPE C2,HIT
02100
02200 TDNE C1,C2 ;WHEN V1 & V2 ARE BEYOND THE WINDOW
02300 POP0J ;IN THE SAME DIRECTION - EASY OUTSIDE.
02400
02500 L: LAC X0,X1↔FSB X0,X2↔MOVMS↔CAMGE X0,[1.0]↔GO[
02600 LAC Y0,Y1↔FSB Y0,Y2↔MOVMS↔CAMGE Y0,[1.0]↔GO HIT↔GO .+1]
02700 LAC X0,X1↔FAD X0,X2↔FSC X0,-1 ;MIDPOINT.
02800 LAC Y0,Y1↔FAD Y0,Y2↔FSC Y0,-1
02900
03000 SETZ C0,
03100 CAML Y0,YH↔IORI C0,8 ;NORTH.
03200 CAMG Y0,YL↔IORI C0,4 ;SOUTH.
03300 CAML X0,XH↔IORI C0,2 ;EAST.
03400 CAMG X0,XL↔IORI C0,1 ;WEST.
03500 JUMPE C0,HIT
03600
03700 TDNE C0,C1
03800 GO .+5 ;FIRST HALF EASY OUT.
03900 LAC C2,C0 ;FIRST HALF STILL IN DOUBT.
04000 LAC X2,X0
04100 LAC Y2,Y0↔GO L
04200
04300 TDNE C0,C2
04400 POP0J ;BOTH HALVES EASY OUTSIDE.
04500 LAC C1,C0 ;SECOND HALF STILL IN DOUBT.
04600 LAC X1,X0
04700 LAC Y1,Y0↔GO L
04800
04900 HIT: AOS↔AOS(P)↔POP0J
05000
05100 BEND;2/25/73------------------------------------------------------
00100 REPACK:0;--------------------------------------------------------
00200 BEGIN REPACK
00300 ACCUMULATORS{LO,HI}
00400
00500 ;PACK RIGHT HALFWORDS DOWNWARDS FORMING WINDOW 2.
00600 LAC LO,BEG0↔LAC HI,END0
00700 L1: CAML LO,HI↔GO L2
00800 CDR(LO)↔SKIPE↔AOJA LO,L1 ;SCAN FOR HOLE.
00900 CDR(HI)↔SKIPN↔SOJA HI,.-2 ;SCAN FOR EDGE.
01000 DAP(LO)↔SOS HI↔AOJA LO,L1 ;PUT EDGE IN HOLE.
01100
01200 ;PACK LEFT HALFWORDS DOWNWARDS FORMING WINDOW 1.
01300 L2: LAC LO,BEG0↔LAC HI,END0
01400 L3: CAML LO,HI↔GO L4
01500 CAR(LO)↔SKIPE↔AOJA LO,L3 ;SCAN FOR HOLE.
01600 CAR(HI)↔SKIPN↔SOJA HI,.-2 ;SCAN FOR EDGE.
01700 DIP(LO)↔SOS HI↔AOJA LO,L3 ;PUT EDGE IN HOLE.
01800
01900 ;CLEAR LEFT HALVES OF THE WINDOWS.
02000 L4: LAC HI,END1↔LAC 1,SIZ1 ;COPY WINDOW 1 UP.
02100 LAC LO,BEG0↔ADDI LO,-1(1)
02200 L5: CAR(LO)↔DAPZ(HI)
02300 SOS LO↔SOS HI↔SOJG 1,L5
02400 LAC 1,P2↔ZIP(1)↔AOBJN 1,.-1
02500 GO@REPACK
02600
02700 BEND;2/25/73-----------------------------------------------------
02800
02900 BEND XYSORT
00100 SUBR(VSCAN)----------------------------------------------------
00200 BEGIN VSCAN
00300 ACCUMULATORS{B,F,V,X,Y,Z}
00400 SLACI(400000)↔DAC XPPMAX↔DAC YPPMAX↔DAC ZPPMAX
00500 SETCM↔DAC XPPMIN↔DAC YPPMIN↔DAC ZPPMIN
00600 DZM EOWPTR ;WINDOW DOESN'T EXIST YET.
00700 LAC B,WORLD ;FOR ALL THE BODIES OF THE WORLD.
00800 L1: CCW B,B
00900 TEST B,BBIT↔POP0J
01000 LAC V,B ;FOR ALL THE VERTICES OF EACH BODY.
01100 L2: PVT V,V
01200 TEST V,VBIT↔GO L1
01300 TEST V,POTENT↔GO L2
01400
01500 ;COLLECT EXTREMA.
01600 LAC X,XPP(V)↔CAMGE X,XPPMIN↔GO[
01700 DAC X,XPPMIN↔DAC V,VXMIN↔GO .+1]
01800 LAC Z,ZPP(V)↔CAMGE Z,ZPPMIN↔GO[
01900 DAC Z,ZPPMIN↔DAC V,VZMIN↔GO .+1]
02000 LAC Y,YPP(V)↔CAMGE Y,YPPMIN↔GO[
02100 DAC Y,YPPMIN↔DAC V,VYMIN↔GO .+1]
02200
02300 LAC X,XPP(V)↔CAMLE X,XPPMAX↔GO[
02400 DAC X,XPPMAX↔DAC V,VXMAX↔GO .+1]
02500 LAC Y,YPP(V)↔CAMLE Y,YPPMAX↔GO[
02600 DAC Y,YPPMAX↔DAC V,VYMAX↔GO .+1]
02700 LAC Z,ZPP(V)↔CAMLE Z,ZPPMAX↔GO[
02800 DAC Z,ZPPMAX↔DAC V,VZMAX↔GO .+1]
02900
03000 CDR F,7(V) ;PREVIOUS OVER FACE.
03100 JUMPE F,L2
03200 TEST F,POTENT↔GO L2
03300 DAC V,VERT#↔DAC F,FACE#↔PUSH P,B
03400 CALL(WITHIN,FACE,VERT)↔GO L3
03500 L2B: CALL(ZDEPTH,FACE,VERT)↔JUMPE L3
03600 L2C: CALL(VHIDE,FACE,VERT)
03700 L3: POP P,B↔LAC V,VERT↔LAC F,FACE↔GO L2
03800 LIT
03900 BEND;2/27/73------------------------------------------------------
00100 SUBR(ESCAN)S0--------------------------------------------------
00200 BEGIN ESCAN; BGB - 10 FEBRUARY 1973.
00300 ACCUMULATORS{E1,E2}
00400 AOS WNDCNT
00500
00600 ;DIAGONOSTIC DISPLAY WINDOW FRAME.
00700 SKIPE DMODE↔GO[CALL(WINDPY,ARG1)
00800 CALL({VERIFY+2},[ASCIZ/ESCAN/],[0])↔GO .+1]
00900
01000 ;COMPARE EACH EDGE IN THE WINDOW WITH ALL THE OTHERS,
01100 ;WHEN TWO EDGES CROSS MAKE A TJOINT.
01200
01300 L0: LAC E1,ARG1↔DAC E1,EDG1 ;FIRST EDGE.
01400 LAC -5(E1) ;EDGE COUNT.
01500 CAIGE 2↔POP1J ;TAKES AT LEAST TWO.
01600 ADD E1↔DAC EOWPTR ;END OF WINDOW.
01700 DZM@
01800 SOS EDG1
01900
02000 L1: AOS E1,EDG1↔DAC E1,EDG2
02100 SKIPN E1,(E1)↔POP1J ;EXIT.
02200 TEST E1,POTENT↔GO L1
02300
02400 L2: AOS E2,EDG2
02500 SKIPN E2,(E2)↔GO L1
02600 TEST E2,POTENT↔GO L2
02700
02800 ;COMPARE EDGES.
02900 CALL(COMPEE,@EDG1,@EDG2)
03000 JUMPLE 1,L2
03100 CAIN 1,441↔GO[CALL(MKTJ,@EDG1,@EDG2)↔GO L2]
03200 GO L2
03300
03400 DECLARE{EDG1,EDG2}
03500 BEND;2/10/73------------------------------------------------------
03600
03700 ;END OF WINDOW POINTER.
03800 EOWPTR: 0
00100 SUBR(MKTJ)FOLD,EDGE ---------------------------------------------
00200 BEGIN MKTJ; MAKE T-JOINT.
00300
00400 LAC ARG2↔DAC FOLD
00500 LAC ARG1↔DAC EDGE
00600 SETQ(JOT,{EBREAK,FOLD})
00700 SETQ(JUT,{EBREAK,EDGE})
00800
00900 ;DISTINGUISH ZPP-OVER ≥ ZPP-UNDER.
01000 LAC 1,JUT↔LAC 2,JOT
01100 TJOIN. 1,2↔TJOIN. 2,1
01200 LAC 0,ZPP(1)↔CAMG 0,ZPP(2)↔GO .+7↔EXCH 1,2
01300 DAC 1,JUT↔DAC 2,JOT
01400 LAC EDGE↔EXCH FOLD↔DAC EDGE
01500 MARK 1,JUTBIT↔MARK 2,JOTBIT
01600
01700 ;ORIENT EDGES WITH RESPECT TO FOLD FACES.
01800 LAC 1,FOLD
01900 PFACE 0,1↔DAC FACE1
02000 NFACE 0,1↔DAC FACE2
02100 SLACI(POTENT)↔AND@FACE1↔AND@FACE2↔ANDCAM@JUT
02200 SETQ(V,{OTHER,EDGE,JUT})
02300 LAC 1,JUT↔PED 1,1↔DAC 1,EJUT
02400 CALL(QFEV,FACE1,FOLD,V)
02500 JUMPG 1,[LAC EDGE↔EXCH EJUT↔DAC EDGE↔GO .+1]
02600
02700 ;HIDE UNDER EDGES.
02800 CALL(,FACE1,EJUT,JUT)
02900 CALL(EHIDE,FACE2,EDGE,JUT)
03000 CALL(EHIDE)
03100 POP2J
03200 COMMENT . ⊗ MAKE T-JOINT MANDALA
03300 |
03400 |
03500 FACE2 FOLD FACE1
03600 |
03700 EDGE ⊗JOT EJUT
03800 ⊗-------------⊗-|------------⊗
03900 V JUT|
04000 |
04100 ⊗ .
04200 DECLARE{FOLD,EDGE,EJUT,JOT,JUT,FACE1,FACE2,V}
04300 BEND MKTJ; BGB 14 FEB 73.-----------------------------------------
00100 SUBR(EHIDE)FACE,EDGE,VERTEX --------------------------------------
00200 BEGIN EHIDE; EDGE HIDE - BGB - 14 FEBRUARY 1973.
00300
00400 LAC 1,ARG2↔DAC 1,EDGE↔TEST 1,POTENT↔POP3J
00500 LAC 2,ARG3↔DAC 2,FACE↔TEST 2,POTENT↔POP3J
00600 ALT. 1,2↔PED 0,2↔DAC EDG0↔DAC EDG1
00700 LAC ARG1↔DAC V1↔SETQ(V2,{OTHER,EDGE,V1})
00800 SKIPE DMODE↔GO[CALL(VERIFY,[ASCII/EHIDE/],[3])↔GO .+1]
00900
01000 ;QMASK←(IF V2=NVT(E) THEN 200 ELSE 100).
01100 LACI 200↔LAC 1,EDGE↔NVT 1,1
01200 CAME 1,V2↔LACI 100↔DAC QMASK
01300
01400 ;COMPARE EDGE WITH FACE.
01500 L1: CALL(COMPEE,EDGE,EDG1)
01600 JUMPLE 1,L2 ;DISJOINT.
01700 TDNE 1,QMASK↔GO L3 ;V2 TOUCHING EDG1.
01800 TRNN 1,1↔GO L2 ;CROSSING.
01900
02000 ;CROSSING - CONTINUE INTO NEXT FACE OR MAKE A TJOINT.
02100 L4: CALL(OTHER,EDG1,FACE)
02200 TEST 1,POTENT↔GO L5
02300 ALT 0,1↔CAMN 0,EDGE↔POP3J ;DON'T VISIT SAME FACE TWICE.
02400 LAC 0,EDGE↔ALT. 0,1
02500 DAC 1,FACE↔LAC EDG1↔DAC EDG0
02600
02700 ;DISJOINT - CONTINUE ON THIS FACE OR HIDE EDGE.
02800 L2: SETQ(EDG1,{ECCW,EDG1,FACE})
02900 CAME 1,EDG0↔GO L1
03000 LAC 1,EDGE↔MARKZ 1,POTENT ;HIDE THIS EDGE.
03100 CALL(DPYALL)
03200 CALL(VHIDE,FACE,V2)↔POP3J ;HIDE ALL ITS FRIENDS.
03300
03400 ;TOUCHING.
03500 L3: ;OUTSTR[ASCIZ/TOUCH /]
03600 LAC 1,EDGE↔MARKZ 1,POTENT
03700 CALL(DPYALL)↔POP3J
03800
03900 ;MAKE A TJOINT.
04000 L5: LAC 1,EDGE↔MARKZ 1,POTENT
04100 PVT 1,1↔CAME 1,V2↔GO[CALL(INVERT,EDGE)↔GO .+1]
04200 CALL(EBREAK,EDGE)↔MARK 1,JUTBIT↔PUSH P,1 ;JOINT UNDER T.
04300 CALL(EBREAK,EDG1)↔MARK 1,JOTBIT↔POP P,2 ;JOINT OVER T.
04400 TJOIN. 1,2↔TJOIN. 2,1
04500 CALL(DPYALL)↔POP3J
04600 LIT
04700 DECLARE{FACE,EDG0,EDG1,EDGE,V1,V2,QMASK}
04800 BEND;2/14/73------------------------------------------------------
00100 SUBR(VHIDE)FACE,VERTEX -----------------------------------------
00200 BEGIN VHIDE; HIDE VERTEX V UNDER FACE F.
00300 ;VHIDE IS CALLED RECURSIVELY FROM EHIDE SO TEMPORARY CELLS FOR
00400 ;V0 AND Z-FACE ARE KEPT IN THE LEFT HALF OF ARG1 AND ARG2.
00500 ACCUMULATORS{V,E,E0}
00600 CDR V,ARG1↔TEST V,POTENT↔POP2J
00700 SKIPE DMODE↔GO[
00800 CALL(VERIFY,[ASCII/VHIDE/],[2])↔CDR V,ARG1↔GO .+1]
00900 DIP V,ARG1 ;V0.
01000 MARKZ V,POTENT
01100 CDR 1,ARG2↔DAP 1,7(V) ;FACE HIDES VERTEX.
01200 CALL(ZDEPTH,1,V)↔HLLM 1,ARG2 ;Z FACE LEVEL.
01300
01400 L1: CDR V,ARG1↔LAC 0,ZPP(V)↔CAML 0,ARG2↔GO L4
01500 L2: CDR V,ARG1↔PED E,V↔DAC E,E0
01600 L3: TEST E,POTENT↔GO[
01700 SETQ(E,{ECCW,E,V})↔CAME E,E0↔GO L3↔GO L4]
01800 CDR ARG2↔CALL(EHIDE,0,E,V)↔GO L2
01900 L4: CDR V,ARG1↔TJOINT V,V↔DAP V,ARG1
02000 SKIPN V↔POP2J
02100 CAR ARG1↔CAME V,0↔GO L1↔POP2J ;TEST FOR V0.
02200 LIT
02300 BEND;2/14/73------------------------------------------------------
00100 SUBR(COMPEE)EDG1,EDG2---------------------------------------------
00200 BEGIN COMPEE; COMPARE EDGE-EDGE.
00300 ACCUMULATORS{Q1,Q2,E1,E2,V1,V2,U1,U2}
00400 COMMENT/
00500 -1 EDGES ARE DISJOINT.
00600 0 EDGES E1 AND E2 ARE IDENTICAL.
00700 +441 EDGE CROSS EACH OTHER.
00800 +110 PVT(E1) IS JOINED TO PVT(E2).
00900 +120 PVT(E1) IS JOINED TO NVT(E2).
01000 +210 NVT(E1) IS JOINED TO PVT(E2).
01100 +220 NVT(E1) IS JOINED TO NVT(E2)./
01200 DEFINE EPSLON<[0.01]>
01300 AOS COMCNT
01400 SETZ 1,↔LAC E1,ARG2↔LAC E2,ARG1
01500 CAMN E1,E2↔POP2J; IDENTITY CASE.
01600
01700 ;FETCH ENDPOINTS - RING'A'AROUND TJOINTS TO GET THE JOT.
01800 PVT V1,E1↔NVT V2,E1
01900 PVT U1,E2↔NVT U2,E2
02000 TESTZ V1,JUTBIT↔GO[TJOINT V1,V1↔GO .-2]
02100 TESTZ V2,JUTBIT↔GO[TJOINT V2,V2↔GO .-2]
02200 TESTZ U1,JUTBIT↔GO[TJOINT U1,U1↔GO .-2]
02300 TESTZ U2,JUTBIT↔GO[TJOINT U2,U2↔GO .-2]
02400
02500 ;TEST FOR EDGES ALREADY HAVINGS A VERTEX OR TJOINT IN COMMON.
02600 NIM 1,110↔CAMN V1,U1↔POP2J
02700 NIM 1,120↔CAMN V1,U2↔POP2J
02800 NIM 1,210↔CAMN V2,U1↔POP2J
02900 NIM 1,220↔CAMN V2,U2↔POP2J
03000
03100 ;THE SPAN OVERLAPPING TESTS PREVENT NASTY PARALLEL CASES.
03200 ;TEST FOR X-SPAN NOT OVERLAPPING.
03300 LO1←←0 ↔ HI1←←1 ↔ LO2←←2 ↔ HI2←←3
03400 LAC LO1,XPP(V1)↔LAC HI1,XPP(V2)↔CAMG HI1,LO1↔EXCH HI1,LO1
03500 LAC LO2,XPP(U1)↔LAC HI2,XPP(U2)↔CAMG HI2,LO2↔EXCH HI2,LO2
03600 CAMG LO1,HI2↔GO .+4↔FSBR LO1,HI2↔CAMLE LO1,EPSLON↔GO L0
03700 CAMG LO2,HI1↔GO .+4↔FSBR LO2,HI1↔CAMLE LO2,EPSLON↔GO L0
03800
03900 ;TEST FOR Y-SPAN NOT OVERLAPPING.
04000 LAC LO1,YPP(V1)↔LAC HI1,YPP(V2)↔CAMG HI1,LO1↔EXCH HI1,LO1
04100 LAC LO2,YPP(U1)↔LAC HI2,YPP(U2)↔CAMG HI2,LO2↔EXCH HI2,LO2
04200 CAMG LO1,HI2↔GO .+4↔FSBR LO1,HI2↔CAMLE LO1,EPSLON↔GO L0
04300 CAMG LO2,HI1↔GO .+4↔FSBR LO2,HI1↔CAMLE LO2,EPSLON↔GO[L0:
04400 SETO 1,↔POP2J]
00100 ;COMPARE E1 AND U1.
00200 L1: SETZ 1,↔LAC Q1,CC(E1)
00300 LAC BB(E1)↔FMPR YPP(U1)↔FADR Q1,0
00400 LAC AA(E1)↔FMPR XPP(U1)↔FADR Q1,0
00500 LACM Q1↔CAMG EPSLON↔TRO 1,10
00600
00700 ;COMPARE E1 AND U2.
00800 LAC Q2,CC(E1)
00900 LAC BB(E1)↔FMPR YPP(U2)↔FADR Q2,0
01000 LAC AA(E1)↔FMPR XPP(U2)↔FADR Q2,0
01100 LACM Q2↔CAMG EPSLON↔TRO 1,20
01200
01300 ;EXIT WHEN U1 AND U2 ARE CLEAR OF E1 ON THE SAME SIDE.
01400 XOR Q1,Q2↔JUMPGE Q1,[TRNE 1,30↔GO .+2↔SETO 1,↔POP2J]
01500 TRO 1,40 ;E1 CROSSES E2'S LINE.
01600
01700 ;COMPARE E2 AND V1.
01800 LAC Q1,CC(E2)
01900 LAC BB(E2)↔FMPR YPP(V1)↔FADR Q1,0
02000 LAC AA(E2)↔FMPR XPP(V1)↔FADR Q1,0
02100 LACM Q1↔CAMG EPSLON↔TRO 1,100
02200
02300 ;COMPARE E2 AND V2.
02400 LAC Q2,CC(E2)
02500 LAC BB(E2)↔FMPR YPP(V2)↔FADR Q2,0
02600 LAC AA(E2)↔FMPR XPP(V2)↔FADR Q2,0
02700 LACM Q2↔CAMG EPSLON↔TRO 1,200
02800
02900 ;EXIT WHEN V1 AND V2 ARE CLEAR OF E2 ON THE SAME SIDE.
03000 XOR Q1,Q2↔JUMPGE Q1,[TRNE 1,300↔GO .+2↔SETO 1,↔POP2J]
03100 TRO 1,400 ;E2 CROSSES E1'S LINE.
03200
03300 ;ELIMINATE COINCIDANT EDGE-VERTEX OCCURENCES BY FUDGING.
03400 TRNE 1,010↔GO[CALL(FUDGE,U1,E1)↔GO L1] ;U1 NEAR E1'S LINE.
03500 TRNE 1,020↔GO[CALL(FUDGE,U2,E1)↔GO L1] ;U2 NEAR E1'S LINE.
03600 TRNE 1,100↔GO[CALL(FUDGE,V1,E2)↔GO L1] ;V1 NEAR E2'S LINE.
03700 TRNE 1,200↔GO[CALL(FUDGE,V2,E2)↔GO L1] ;V2 NEAR E2'S LINE.
03800
03900 ;SOLVE FOR CROSSING LOCUS.
04000 L2: DAC 1,AC1
04100 LAC AA(E1)↔FMPR BB(E2)
04200 LAC 1,AA(E2)↔FMPR 1,BB(E1)↔FSBR 0,1↔DAC TT#
04300 LAC BB(E1)↔FMPR CC(E2)
04400 LAC 1,BB(E2)↔FMPR 1,CC(E1)↔FSBR 0,1↔FDVR 0,TT↔DAC XCROSS
04500 LAC CC(E1)↔FMPR AA(E2)
04600 LAC 1,CC(E2)↔FMPR 1,AA(E1)↔FSBR 0,1↔FDVR 0,TT↔DAC YCROSS
04700 LAC XCROSS↔FMPR[3.5]↔DAC XCRUX
04800 LAC YCROSS↔FMPR[3.5]↔DAC YCRUX
04900 LAC 1,AC1↔TRO 1,1↔POP2J
05000 BEND;3/1/73-------------------------------------------------------
05100 DECLARE{XCROSS,YCROSS,ZCROSS,XCRUX,YCRUX}
00100 SUBR(FUDGE)VERTEX,EDGE -------------------------------------------
00200 BEGIN FUDGE; MOVE 2D VERTEX LOCUS AWAY FROM THE EDGE ALITTLE.
00300 EXTERN ECOEF
00400 ACCUMULATORS{V,E}↔SAVAC(11)
00450 SKIPE DMODE↔GO[CALL(VERIFY,[ASCII/FUDGE/],[2])↔GO .+1]
00500 LAC V,ARG2↔LAC E,ARG1↔DAC V,VERT
00600 LAC BB(E)↔FSC -3↔FADRM YPP(V)
00700 LAC AA(E)↔FSC -3↔FADRM XPP(V)
00800 PED E,V↔DAC E,E0↔DAC E,E1
00900 L: CALL(ECOEF,E1)
01000 SETQ(E1,{ECCW,E1,VERT})
01100 CAME 1,E0↔GO L
01200 GETAC(11)↔POP2J
01300 DECLARE{E0,E1,VERT}
01400 BEND FUDGE;BGB 3/1/73---------------------------------------------
01500
01600
01700 SUBR(ZDEDGE)EDGE -------------------------------------------------
01800 BEGIN ZDEDGE; SOLVE FOR ZDEPTHS AT THE CROSSING(XCROSS,YCROSS).
01900 ;Z←((Z2-Z1)*(XCROSS-X1)/(X2-X1))+Z1
02000 ACCUMULATORS{E,V1,V2}
02100
02200 LAC E,ARG1
02300 PVT V1,E↔NVT V2,E
02400 LACM 0,AA(E)↔LACM 1,BB(E)↔CAMGE 1,0↔GO L
02500
02600 ;WHEN DX ≥ DY:
02700 LAC 1,ZPP(V2)↔FSBR 1,ZPP(V1)
02800 LAC 0,XCROSS↔ FSBR 0,XPP(V1)↔FMPR 1,0
02900 LAC 0,XPP(V2)↔FSBR 0,XPP(V1)↔FDVR 1,0
03000 FADR 1,ZPP(V1)↔DAC 1,ZCROSS↔POP1J
03100
03200 ;WHEN DY > DX:
03300 L: LAC 1,ZPP(V2)↔FSBR 1,ZPP(V1)
03400 LAC 0,YCROSS↔ FSBR 0,YPP(V1)↔FMPR 1,0
03500 LAC 0,YPP(V2)↔FSBR 0,YPP(V1)↔FDVR 1,0
03600 FADR 1,ZPP(V1)↔DAC 1,ZCROSS↔POP1J
03700 BEND;2/10/73------------------------------------------------------
00100 SUBR(EBREAK)EDGE -------------------------------------------------
00200 BEGIN EBREAK;EBREAK(EDGE) IS LIKE ESPLIT.
00300 ACCUMULATORS{B,E,V,Q,R,ENEW,VNEW,PV,NV}
00400
00500 ;GET ZDEPTH AT CROSSING.
00600 CALL(ZDEDGE,ARG1)
00700 ;CREATE A NEW EDGE AND A NEW VERTEX.
00800 CDR E,ARG1↔PVT V,E↔CCW B,E
00900 SETQ(VNEW,{MKV,B})↔MARK VNEW,TMPBIT+POTENT
01000 EXCH 1,TJLIST↔TJ. 1,VNEW ;CONS VNEW TO TJ LIST.
01100 LAC XCROSS↔DAC XPP(VNEW)↔LAC XCRUX↔XDC. 0,VNEW
01200 LAC YCROSS↔DAC YPP(VNEW)↔LAC YCRUX↔YDC. 0,VNEW
01300 LAC ZCROSS↔DAC ZPP(VNEW)
01400 SETQ(ENEW,{MKE,B})↔MARK ENEW,POTENT
01500 TESTZ E,FOLDED↔GO[MARK ENEW,FOLDED↔GO .+1]
01510 TESTZ E,DARKEN↔GO[MARK ENEW,DARKEN↔GO .+1]
01600
01700 ;COPY EDGE COEFFICIENTS.
01800 SLACI AA(E)↔LAPI AA(ENEW)↔BLT CC(ENEW)
01850 LAC 8(E)↔DAC 8(ENEW)
01900 ;PLACE EDGE AT END OF POTENT EDGE LIST.
02000 LAC 1,WORLD↔NED 2,1↔NED. ENEW,1↔POTEN. ENEW,2
02100 SKIPN EOWPTR↔GO .+4
02200 DAC ENEW,@EOWPTR↔AOS EOWPTR↔DZM@EOWPTR
02300 ;PLACE VNEW BETWEEN E AND ENEW.
02400 PED 0,V↔CAMN 0,E↔PED. ENEW,V
02500 PED. ENEW,VNEW↔PVT PV,E↔PVT. PV,ENEW
02600 PVT. VNEW,E↔NVT. VNEW,ENEW
02700 PFACE 0,E↔PFACE. 0,ENEW
02800 NFACE 0,E↔NFACE. 0,ENEW
02900 ;NEW UPPER WINGS ARE LIKE THE OLDE;
03000 PCW 0,E↔CALL(WING,0,ENEW)
03100 NCCW 0,E↔CALL(WING,0,ENEW)
03200 ;EDGES POINT AT EACH OTHER ACROSS VNEW.
03300 NCCW. ENEW,E↔PCW. ENEW,E
03400 NCW. E,ENEW↔PCCW. E,ENEW
03500 LAC 1,VNEW↔POP1J
03600 COMMENT . _________ __________ EBREAK MANDALA
03700 nccw \ / pcw
03800 \ /
03900 + ⊗ V
04000 +|
04100 | ENEW
04200 -|
04300 ⊗ VNEW
04400 +|
04500 | E
04600 -|
04700 - ⊗
04800 / \
04900 ___ncw___/ \___pccw___.
05000 BEND;2/10/73------------------------------------------------------
00100 SUBR(TJSCAN)------------------------------------------------------
00200 BEGIN TJSCAN; SCAN TJ LIST & PROMULAGATE UNDER FACES.
00300 ACCUMULATORS{UF1,UF2,JUT,JOT,F1,F2,E,E1,E2,V1}
00400 ;SCAN THRU TJ-LIST FOR POTENT JUTS.
00500 SKIPA JUT,TJLIST; ⊗V1
00600 L1: TJ JUT,JUT; |
00700 SKIPN JUT↔POP0J; F1 UF1 |E1
00800 TEST JUT,JUTBIT↔GO L1; |
00900 TEST JUT,POTENT↔GO L1; EDGE JUT ⊗JOT
01000 PUSH P,JUT; ⊗-------------⊗-|------------⊗
01100 ; |
01200 ; F2 UF2 |E2
01300 ; |
01400 ; ⊗
01500
01600 ;PICKUP ALL THE FRIENDS OF THE PRESENT JUT.
01700 TJOINT JOT,JUT↔PED E1,JOT ;JOT'S EDGES.
01800 SETQ(E2,{ECCW,E1,JOT})
01900 SETQ(V1,{OTHER,E1,JOT})
02000 PED E,JUT↔TEST E,POTENT↔GO[ ;POTENT JUT EDGE.
02100 SETQ(E,{ECCW,E,JUT})↔GO .+1]
02200 PFACE F1,E↔TEST F1,POTENT↔DZM F1 ;POTENT JUT FACES.
02300 NFACE F2,E↔TEST F2,POTENT↔DZM F2
02400
02500 ;FORCE ORIENTATION AS IN THE MANDALA.
02600 LAC 1,CC(E)
02700 LAC BB(E)↔FMPR YPP(V1)↔FADR 1,0
02800 LAC AA(E)↔FMPR XPP(V1)↔FADR 1,0
02900 SKIPG 1↔EXCH E1,E2
03000
03100 ;TRY TO HIDE THE JUT.
03200 UFACE UF1,E1↔SKIPE UF1
03300 CAMN UF1,F1↔GO L2
03400 CALL(ZDEPTH,UF1,JUT)↔JUMPE L2
03500 CALL(VHIDE,UF1,JUT)↔GO L9
03600 L2: UFACE UF2,E2↔SKIPE UF2
03700 CAMN UF2,F2↔GO L3
03800 CALL(ZDEPTH,UF2,JUT)↔JUMPE L3
03900 CALL(VHIDE,UF2,JUT)↔GO L9
04000
04100 ;PROMULGATE UNDERFACES OF THIS JOT.
04200 L3: CALL(,F2,E2,JOT)
04300 CALL(PROMUL,F1,E1,JOT)
04400 CALL(PROMUL)
04500 L9: POP P,JUT↔GO L1
04600
04700 BEND TJSCAN;BGB 4 MARCH 1973 -------------------------------------
00100 SUBR(PROMUL)UF,EDGE,VERTEX----------------------------------------
00200 BEGIN PROMUL;PROMULGATE UNDER FACE ALONG THE FOLDS.
00300 ACCUMULATORS{A2,A3,E,V,F,JUT}
00400 SKIPN F,ARG3↔POP3J
00500 LAC E,ARG2↔TEST E,POTENT↔POP3J
00600 LAC V,ARG1↔TEST V,POTENT↔POP3J
00700 SKIPE DMODE↔GO[CALL(VERIFY,[ASCII/PROML/],[3])
00800 LAC F,ARG3↔LAC E,ARG2↔LAC V,ARG1↔GO .+1]
00900
01000 ;PLACE UF IN EDGE IF DIFFERENT FROM THE ONE IT MAY HAVE ALREADY.
01100 UFACE 1,E↔CAMN 1,F↔POP3J ;CONSISTENT.
01200 UFACE. F,E
01300 L1: SETQ(V,{OTHER,E,V})
01400 TESTZ V,JUTBIT↔POP3J
01500 TESTZ V,JOTBIT↔GO L3
01600 VALEN 0,V↔CAILE 0,3↔POP3J ;EXIT ON COMPLEX VERTICES.
01700
01800 ;PROMULGATE UNDER FACE THRU A SIMPLE TWO FOLD VERTEX.
01900 DAC E,1
02000 L2: CALL(ECCW,1,V)
02100 CAMN 1,E↔POP3J
02200 TEST 1,FOLDED↔GO L2
02300 GO L1
02400
02500 ;SEE IF WE CAN WIPE THIS JOT'S JUT.
02600 L3: TEST V,VBIT↔GO[FATAL({BUG TRAP PROMUL&L3})]
02700 TJOINT JUT,V
02800 TEST JUT,POTENT↔GO L2-1
02900 PED 1,JUT
03000 PFACE 0,1↔CAMN 0,F↔POP3J
03100 NFACE 0,1↔CAMN 0,F↔POP3J
03200 DAC F,ARG3↔DAC E,ARG2↔DAC V,ARG1
03300 CALL(ZDEPTH,F,JUT)↔JUMPE POP3J.
03400 CALL(WITHIN,F,JUT)↔POP3J
03500 CALL(VHIDE,F,JUT)
03600 GO PROMUL
03700
03800 BEND PROMUL;BGB 4 MARCH 1972 -------------------------------------
00100 SUBR(QEV)E,V------------------------------------------------------
00200 BEGIN QEV
00300 ACCUMULATORS{E,V}
00400 LAC V,ARG1
00500 LAC E,ARG2
00600 LAC 1,CC(E)
00700 LAC BB(E)↔FMPR YPP(V)↔FADR 1,0
00800 LAC AA(E)↔FMPR XPP(V)↔FADR 1,0
00900 POP2J
01000 BEND;2/10/73------------------------------------------------------
01100
01200 SUBR(QFEV)F,E,V --------------------------------------------------
01300 BEGIN QFEV
01400 ACCUMULATORS{E,V}
01500 LAC V,ARG1
01600 LAC E,ARG2
01700 LAC 1,CC(E)
01800 LAC BB(E)↔FMPR YPP(V)↔FADR 1,0
01900 LAC AA(E)↔FMPR XPP(V)↔FADR 1,0
02000 PFACE 0,E↔CAME 0,ARG3↔MOVNS 1
02100 POP3J
02200 BEND;2/10/73------------------------------------------------------
02300
02400 SUBR(CROSSING)X,Y,E1,E2 ------------------------------------------
02500 BEGIN CROSSING
02600 ACCUMULATORS{TT,XPTR,YPTR,E1,E2}
02700 LAC E2,ARG1
02800 LAC E1,ARG2
02900 LAC YPTR,ARG3
03000 LAC XPTR,ARG4
03100 LAC AA(E1)↔FMPR BB(E2)
03200 LAC 1,AA(E2)↔FMPR 1,BB(E1)↔FSBR 0,1↔DAC TT
03300 LAC BB(E1)↔FMPR CC(E2)
03400 LAC 1,BB(E2)↔FMPR 1,CC(E1)↔FSBR 0,1↔FDVR 0,TT↔DAC(XPTR)
03500 LAC CC(E1)↔FMPR AA(E2)
03600 LAC 1,CC(E2)↔FMPR 1,AA(E1)↔FSBR 0,1↔FDVR 0,TT↔DAC(YPTR)
03700 POP4J
03800 BEND;2/10/73------------------------------------------------------
00100 SUBR(ZDEPTH)FACE,VERTEX ------------------------------------------
00200 BEGIN ZDEPTH; RETURN AC0 -1 VERTEX UNDER FACE.
00300 ACCUMULATORS{F,V}
00400 LAC V,ARG1
00500 LAC F,ARG2
00600 LAC 1,KK(F)
00700 LAC AA(F)↔FMPR XPP(V)↔FSBR 1,0
00800 LAC BB(F)↔FMPR YPP(V)↔FSBR 1,0
00900 FDVR 1,CC(F)
01000 SETO↔CAMG 1,ZPP(V)↔SETZ ;ZPP-OVER > ZPP-UNDER.
01100 POP2J
01200 BEND;2/10/73------------------------------------------------------
01300
01400 SUBR(ZDALT)FACE,XPP,YPP ------------------------------------------
01500 BEGIN ZDALT
01600 ACCUMULATORS{F}
01700 LAC F,ARG3
01800 LAC 1,KK(F)
01900 LAC AA(F)↔FMPR ARG2↔FSBR 1,0
02000 LAC BB(F)↔FMPR ARG1↔FSBR 1,0
02100 FDVR 1,CC(F)
02200 POP3J
02300 BEND;2/10/73------------------------------------------------------
02400
02500 SUBR(WITHIN)FACE,VERTEX ------------------------------------------
02600 BEGIN WITHIN
02700 ACCUMULATORS{F,V,E,E0}
02800 LAC F,ARG2
02900 LAC V,ARG1
03000 PED E,F↔DAC E,E0
03100 L1: LAC 1,CC(E)
03200 LAC BB(E)↔FMPR YPP(V)↔FADR 1,0
03300 LAC AA(E)↔FMPR XPP(V)↔FADR 1,0
03400 PFACE 0,E↔CAME 0,F↔MOVNS 1
03500 L2: JUMPLE 1,POP2J. ;VERTEX OUTSIDE FACE.
03600 SETQ(E,{ECCW,E,F})
03700 CAME E,E0↔GO L1
03800 AOS(P)↔POP2J ;SKIP VERTEX WITHIN FACE.
03900 BEND;2/27/73------------------------------------------------------
00100 SUBR(KLJOTS)WORLD-------------------------------------------------
00200 BEGIN KLJOTS
00300 ACCUMULATORS{B,V}
00400 CDR B,ARG1
00500 L1: CCW B,B↔CAMN B,ARG1↔POP1J
00600 ;FOR ALL THE VERTICES OF EACH BODY.
00700 LAC V,B
00800 L2: NVT V,V↔CAMN V,B↔GO L1
00900 TEST V,TMPBIT↔GO L2
01000 TEST V,JOTBIT↔GO L2
01100 NVT V,V↔PUSH P,V↔PUSH P,B
01200 PVT V,V↔CALL(KLEV,V)
01300 POP P,B↔POP P,V↔GO L2+1
01400 BEND KLJOTS; BGB 16 FEB 1973 -------------------------------------
01500
01600 SUBR(KLJUTS)WORLD-------------------------------------------------
01700 BEGIN KLJUTS
01800 ACCUMULATORS{B,V}
01900 LAC B,ARG1
02000 L1: CCW B,B↔CAMN B,ARG1↔POP1J
02200 ;FOR ALL THE VERTICES OF EACH BODY.
02300 LAC V,B
02400 L2: NVT V,V
02500 TEST V,VBIT↔GO L1
02600 TEST V,TMPBIT↔GO L2
02700 TEST V,JUTBIT↔GO L2
02800 NVT V,V↔PUSH P,V↔PUSH P,B
02900 PVT V,V↔CALL(KLEV,V)
03000 POP P,B↔POP P,V↔GO L2+1
03100 BEND KLJUTS; 16 FEB 1973 -----------------------------------------
03200
00100 SUBR(KLTMPS)WORLD-------------------------------------------------
00200 BEGIN KLTMPS; KILL ALL THE TMP VERTICES IN THE WORLD.
00300 ACCUMULATORS{B,V,E}
00400 LAC B,ARG1
00500 L1: CCW B,B↔CAMN B,ARG1↔POP1J
00550
00600 LAC E,B
00700 L2: NED E,E↔CAMN E,B↔GO L3-1
00800 TEST E,TMPBIT↔GO L2
00900 NED E,E↔PUSH P,E↔PUSH P,B
01000 PED E,E↔CALL(KLFE,E)
01100 POP P,B↔POP P,E↔GO L2+1
01200
01300 LAC V,B
01400 L3: NVT V,V↔CAMN V,B↔GO L1
01500 TEST V,TMPBIT↔GO L3
01600 NVT V,V↔PUSH P,V↔PUSH P,B
01700 PVT V,V↔CALL(KLEV,V)
01800 POP P,B↔POP P,V↔GO L3+1
01900 BEND KLTMPS; BGB 16 MARCH 1973 -----------------------------------
00100 SUBR(VERIFY)NAME,ARGCNT ------------------------------------------
00200 BEGIN VERIFY; DIAGONOSTIC DISPLAY FOR VERIFYING CORRECTNESS.
00300 EXTERN IDPY
00400 CALL(DPYSET,DPYBUF)
00500 AOS STEP
00600 CALL(AIVECT,[-=510],[-=220])
00700 CALL(DECDPY,STEP)↔CALL(DPYSTR,{[[ASCIZ/. /]]})
00800 LAC ARG2↔DAC NAME↔CALL(DPYSTR,[NAME])
00900
01000 ;GET POINTER TO HIS ARGUMENTS.
01100 LACI 16,-3(17) ;STACK POINTER TO HIS RETURN ADR.
01200 LAC ARG1↔SUB 16,0
01300 MOVNS↔DIP 0,16 ;AOBJN POINTER.
01400 DAC 16,SAV#
01500 JUMPE 0,L3 ;HE'S GOT NO ARGUMENTS.
01600
01700 ;DISPLAY ARGUMENT LIST.
01800 PUSH P,["("]↔SKIPA
01900 L0: CALL(DTYO,{[","]})↔CDR 1,(16)↔CALL(IDPY,1)↔AOBJN 16,L0
02000 CALL(DTYO,{[")"]})
02100
02200 LAC 16,SAV
02300 L1: CDR 1,(16)↔JUMPE 1,L2 ;GET AN ARGUMENT.
02400 LAC 0,(1) ;GET ITS TYPE BITS.
02500 TLNE(FBIT)↔GO[CALL(FDPY,1)↔GO L2]
02600 TLNE(EBIT)↔GO[CALL(EDPY,1)↔GO L2]
02700 TLNE(VBIT)↔GO[CALL(VDPY,1)↔GO L2]
02800 L2: AOBJN 16,L1
02900
03000 L3: CALL(DPYOUT,[16])
03100 SETZ↔SKIPE RUNFLG↔GO L4
03200
03300 ;NOT RUNNING - SINGLE STEP VERIFICATION.
03400 INCHRW
03500 CAIN 175↔SETOM RUNFLG
03600 CAIL"0"↔CAILE"9"↔POP2J
03700 ANDI 17↔LAC 1,STEP2
03800 IMULI 1,=10↔ADD 1↔DAC STEP2
03900 GO L3
04000
04100 ;RUNNING UNTIL STEP2 OR CHR.
04200 L4: SKIPE 1,STEP2↔CAMLE 1,STEP↔GO .+4
04300 DZM STEP2↔DZM RUNFLG↔GO L3
04400 INCHRS↔POP2J↔DZM RUNFLG↔GO L3
04500 RUNFLG:0
04600 NAME:0↔0
04700 STEP:0
04800 STEP2:0
04900 BEND;2/24/73------------------------------------------------------
00100 FDPY:;------------------------------------------------------------
00200 BEGIN FDPY
00300 LAC 1,ARG1↔DAC 1,F
00400 PED 1,1↔DAC 1,E0↔DAC 1,E
00500 CALL(DPYBRT,[3])
00600 CALL(VCW,E,F)
00700 XDC 0,1↔FIXX↔YDC 1,1↔FIXX 1,↔CALL(AIVECT,0,1)
00800 L: CALL(VCCW,E,F)
00900 XDC 0,1↔FIXX↔YDC 1,1↔FIXX 1,↔CALL(AVECT,0,1)
01000 SETQ(E,{ECCW,E,F})
01100 CAME 1,E0↔GO L↔CALL(DPYBRT,[2])↔POP1J
01200 DECLARE{F,E,E0}
01300 BEND;2/10/73------------------------------------------------------
01400
01500 DPYALL:;----------------------------------------------------------
01600 BEGIN DPYALL
01700 EXTERN AIVECT,AVECT
01800 SKIPN DMODE↔POP0J
01900 CALL(DPYSET,DPYBUF)
02000 LAC 1,WORLD↔DAC 1,B
02100 L1: LAC 1,B#↔CCW 1,1↔DAC 1,B
02200 TEST 1,BBIT↔GO[CALL(DPYOUT,[1])↔POP0J]
02300 DAC 1,E#↔DZM CNT#
02400 L2: LAC 1,E↔PED 1,1↔DAC 1,E↔AOS CNT
02500 TEST 1,EBIT↔GO L1
02600 TEST 1,POTENT↔GO L2
02700 PVT 2,1↔NVT 3,1
02800 XDC 0,3↔FIXX↔PUSH P,
02900 YDC 0,3↔FIXX↔PUSH P,
03000 XDC 0,2↔FIXX↔PUSH P,
03100 YDC 0,2↔FIXX↔PUSH P,
03200 CALL(AIVECT)
03300 CALL(AVECT)
03400 GO L2
03500 BEND;2/10/73------------------------------------------------------
00100 SUBR(WINDPY)S0 ---------------------------------------------------
00200 BEGIN WINDPY; WINDOW DISPLAY.
00300 E←←S0←←12↔XL←←13↔XH←←14↔YL←←15↔YH←←16
00400 CALL(DPYSET,DPYBUF)↔LAC 1,ARG1
00500 SLACI -4(1)↔LAPI XL↔BLT YH
00600 FMP XL,[3.5]↔FIXX XL,↔FMP YL,[3.5]↔FIXX YL,
00700 FMP XH,[3.5]↔FIXX XH,↔FMP YH,[3.5]↔FIXX YH,
00800 CALL(AIVECT,XL,YL)
00900 CALL(AVECT,XH,YL)↔CALL(AVECT,XH,YH)
01000 CALL(AVECT,XL,YH)↔CALL(AVECT,XL,YL)
01100 CALL(DPYOUT,[14])↔CALL(DPYBRT,[5])
01200 LAC S0,ARG1↔LACN -5(S0)↔DIP S0
01300 SKIPE↔GO[LAC 1,(S0)↔PVT 2,1↔NVT 1,1
01400 XDC XL,1↔YDC YL,1↔XDC XH,2↔YDC YH,2
01500 FIXX XL,↔FIXX YL,↔FIXX XH,↔FIXX YH,
01600 CALL(AIVECT,XL,YL)↔CALL(AVECT,XH,YH)
01700 AOBJN S0,.↔GO .+1]
01800 LAC 1,ARG1↔LAC E,-6(1)
01900 L1: POTEN E,E↔JUMPE E,POP1J.
02000 TEST E,POTENT↔GO L1
02100 CALL(EDPY,E)↔GO L1
02200 POP1J
02300 BEND WINDPY;
00100 SUBR(STAT)--------------------------------------------------------
00200 BEGIN STAT; DISPLAY OCCULT STATISTICS.
00300 CALL(DPYSET,BUFDPY)
00400 SETZ↔TIMER↔SUB TIME1↔MOVM↔FLOAT↔FDVR[60.0]↔DAC TIME1
00500 SETZ↔RUNTIM↔SUB TIME2↔MOVM↔FLOAT↔FDVR[1000.0]↔DAC TIME2
00600 FDVR TIME1↔FMPR[100.0]↔FIXX↔DAC RATIO#
00700
00800 CALL(DPYBIG,[1])
00900 CALL(AIVECT,[=380],[=430])
01000 CALL(DPYSTR,{[[ASCIZ/REAL TIME /]]})
01100 CALL(FLODPY,TIME1,[2])
01200 CALL(AIVECT,[=380],[=410])
01300 CALL(DPYSTR,{[[ASCIZ/RUN TIME /]]})
01400 CALL(FLODPY,TIME2,[2])
01500 CALL(AIVECT,[=380],[=390])
01600 CALL(DPYSTR,{[[ASCIZ/TIME SHARE /]]})
01700 CALL(DECDPY,RATIO)
01800 CALL(DTYO,["%"])
01900
02000 CALL(AIVECT,[=150],[-=400])
02100 CALL(DPYSTR,{[[ASCIZ/PDLTOP /]]})↔CALL(DECDPY,PDLTOP)
02200 CALL(DPYSTR,{[[ASCIZ/ WINDOWS /]]})↔CALL(DECDPY,WNDCNT)
02300 CALL(DPYSTR,{[[ASCIZ/ COMPARES /]]})↔CALL(DECDPY,COMCNT)
02400 CALL(DPYBIG,[2])
02500 CALL(DPYOUT,[16])
02600
02700 SKIPN DMODE↔POP0J
02800 CALL(DPYSET,DPYBUF)
02900 CALL(DPYOUT,[15])
03000 CALL(DPYOUT,[14])
03100 POP0J
03200 LIT
03300 BEND STAT;BGB 3/4/73----------------------------------------------
03400
03500 END